Dr. Windows 3/dr win3.zip/dr win3/UTILITY1/MSWLGO35.ZIP/EXAMPLES/ALGS

Text File | 1993-04-11 | 7KB | 273 lines

;
; This appears to be a grabbag of assorted log algorythms
;
TO ACOUNT :ARRAY
OUTPUT COUNT :ARRAY
END

TO ADDCHILD :TREE :CHILD
MAKE :TREE LPUT :CHILD THING :TREE
END

TO ADECK
LOCAL [RANKS SUITS]
MAKE "RANKS LISTTOARRAY [A 2 3 4 5 6 7 8 9 10 J Q K]
MAKE "SUITS LISTTOARRAY [H S D C]
MAKE "DECK ARRAY 52
MAKE "INDEX 0
FOR [J 0 3] ~
    [FOR [I 0 12] ~
         [PARRAY :DECK :INDEX WORD (GARRAY :RANKS :I) (GARRAY :SUITS :J) ~
          MAKE "INDEX :INDEX+1]]
END

TO AEQUALP :ARRAY1 :ARRAY2
OP EQUALP :ARRAY1 :ARRAY2
END

TO GARRAY :ARRAY :INDEX
OP ITEM :INDEX+1 :ARRAY
END

TO PARRAY :ARRAY :INDEX :VALUE
SETITEM :INDEX+1 :ARRAY :VALUE
END

TO AREACODE :PAIR
OUTPUT FIRST :PAIR
END

TO ASHUFFLE
ADECK
FOR [I 51 1] [ASHUFFLE1 :I (RANDOM :I+1) (GARRAY :DECK :I)]
END

TO ASHUFFLE1 :I :J :OLDI
PARRAY :DECK :I (GARRAY :DECK :J)
PARRAY :DECK :J :OLDI
END

TO BALANCE :LIST
IF EMPTYP :LIST [OUTPUT []]
IF EMPTYP BF :LIST [OUTPUT LEAF FIRST :LIST]
OUTPUT BALANCE1 (INT (COUNT :LIST)/2) :LIST []
END

TO BALANCE1 :COUNT :IN :OUT
IF EQUALP :COUNT 0 ~
   [OUTPUT TREE (FIRST :IN) (LIST BALANCE REVERSE :OUT BALANCE BF :IN)]
OUTPUT BALANCE1 (:COUNT-1) (BF :IN) (FPUT FIRST :IN :OUT)
END

TO CHILDREN :NODE
OUTPUT BUTFIRST THING :NODE
END

TO CITIES :NAME
OUTPUT CITIES1 FINDDATUM :NAME :WORLD
END

TO CITIES1 :SUBTREE
IF LEAFP :SUBTREE [OUTPUT (LIST DATUM :SUBTREE)]
OUTPUT MAP.SE [CITIES1 ?] CHILDREN :SUBTREE
END

TO CITY :PAIR
OUTPUT BUTFIRST :PAIR
END

TO DATUM :NODE
OUTPUT FIRST THING :NODE
END

TO FINDDATUM :NAME :TREE
IF EQUALP :NAME DATUM :TREE [OUTPUT :TREE]
OUTPUT TRANSFER [NOT EMPTYP ?OUT] [FINDDATUM :NAME ?IN] CHILDREN :TREE
END

TO HIGHBRANCH :TREE
IF LEAFP :TREE [OUTPUT []]
OUTPUT LAST CHILDREN :TREE
END

TO HOWMANY
PRINT :COMPARISONS
ERN "COMPARISONS
END

TO LDECK
OUTPUT CROSSMAP [WORD :1 :2] [[A 2 3 4 5 6 7 8 9 10 J Q K] [H S D C]]
END

TO LEAF :DATUM
OUTPUT TREE :DATUM []
END

TO LEAFP :NODE
OUTPUT EMPTYP CHILDREN :NODE
END

TO LEAVES :LEAVES
OUTPUT MAP [LEAF ?] :LEAVES
END

TO LESSTHANP :A :B
IF NOT NAMEP "COMPARISONS [MAKE "COMPARISONS 0]
MAKE "COMPARISONS :COMPARISONS+1
OUTPUT :A < :B
END

TO LISTCITY :CODE
OUTPUT CITY FIND [EQUALP :CODE AREACODE ?] :CODELIST
END

TO LOCATE :CITY
OUTPUT LOCATE1 :CITY :WORLD
END

TO LOCATE1 :CITY :SUBTREE
LOCAL "RESULT
IF LEAFP :SUBTREE [OUTPUT IFELSE EQUALP :CITY DATUM :SUBTREE [(LIST :CITY)] [[]]]
MAKE "RESULT TRANSFER [NOT EMPTYP ?OUT] [LOCATE1 :CITY ?IN] CHILDREN :SUBTREE
IF EMPTYP :RESULT [OUTPUT []]
OUTPUT FPUT (DATUM :SUBTREE) :RESULT
END

TO LOWBRANCH :TREE
IF LEAFP :TREE [OUTPUT []]
OUTPUT FIRST CHILDREN :TREE
END

TO LSHUFFLE :DECK
IF EMPTYP :DECK [OUTPUT []]
LOCAL "INDEX
MAKE "INDEX 1+RANDOM COUNT :DECK
OUTPUT FPUT (ITEM :INDEX :DECK) (LSHUFFLE (REMOVEITEM :INDEX :DECK))
END

TO NEXTROW :COMBS
IF EMPTYP BF :COMBS [OUTPUT :COMBS]
OUTPUT FPUT (SUM FIRST :COMBS FIRST BF :COMBS) NEXTROW BF :COMBS
END

TO PSORT :LIST
LOCAL "SPLIT
IF (COUNT :LIST) < 2 [OUTPUT :LIST]
MAKE "SPLIT (SUM FIRST :LIST LAST :LIST)/2
IF LESSTHANP FIRST :LIST :SPLIT ~
   [OUTPUT PSORT1 :SPLIT (BF :LIST) (LIST FIRST :LIST) []]
OUTPUT PSORT1 :SPLIT (BL :LIST) (LIST LAST :LIST) []
END

TO PSORT1 :SPLIT :IN :LOW :HIGH
IF EMPTYP :IN [OUTPUT SE PSORT :LOW PSORT :HIGH]
IF LESSTHANP FIRST :IN :SPLIT ~
   [OUTPUT PSORT1 :SPLIT (BF :IN) (FPUT FIRST :IN :LOW) :HIGH]
OUTPUT PSORT1 :SPLIT (BF :IN) :LOW (FPUT FIRST :IN :HIGH)
END

TO QUADRATIC :A :B :C
LOCAL [ROOT X1 X2]
MAKE "ROOT SQRT (:B * :B-4 * :A * :C)
MAKE "X1 (-:B+:ROOT)/(2 * :A)
MAKE "X2 (-:B-:ROOT)/(2 * :A)
PRINT (SE [THE SOLUTIONS ARE] :X1 "AND :X2)
END

TO REALT :N :K
IF EQUALP :K 0 [OUTPUT 1]
IF EQUALP :N 0 [OUTPUT 0]
OUTPUT (T :N :K-1) + (T :N-1 :K)
END

TO REMOVEITEM :NUMBER :LIST
IF EQUALP :NUMBER 1 [OUTPUT BF :LIST]
OUTPUT FPUT (FIRST :LIST) (REMOVEITEM :NUMBER-1 BF :LIST)
END

TO SIMPLEX :BUTTONS
OUTPUT 2 * FIRST CASCADE.2 :BUTTONS ~
                           [FPUT (SUMPRODS BF ?2 ?1) ?1] [1] ~
                           [FPUT 1 NEXTROW ?2] [1 1]
END

TO SSORT :LIST
IF (COUNT :LIST) < 2 [OUTPUT :LIST]
OUTPUT SSORT1 (FIRST :LIST) (BF :LIST) []
END

TO SSORT1 :MIN :IN :OUT
IF EMPTYP :IN [OUTPUT FPUT :MIN SSORT :OUT]
IF LESSTHANP :MIN (FIRST :IN) [OP SSORT1 :MIN (BF :IN) (FPUT FIRST :IN :OUT)]
OUTPUT SSORT1 (FIRST :IN) (BF :IN) (FPUT :MIN :OUT)
END

TO SUMPRODS :A :B
IF EMPTYP :A [OUTPUT 0]
OUTPUT SUM (PRODUCT FIRST :A FIRST :B) (SUMPRODS BF :A BF :B)
END

TO T :N :K
LOCAL "RESULT
MAKE "RESULT GPROP (WORD "N :N) (WORD "K :K)
IF NOT EMPTYP :RESULT [OUTPUT :RESULT]
MAKE "RESULT REALT :N :K
PPROP (WORD "N :N) (WORD "K :K) :RESULT
OUTPUT :RESULT
END

TO TREE :DATUM :CHILDREN
LOCAL "NODE
MAKE "NODE GENSYM
MAKE :NODE FPUT :DATUM :CHILDREN
OUTPUT :NODE
END

TO TREECITY :CODE
OUTPUT CITY TREECITY1 :CODE :CODETREE
END

TO TREECITY1 :CODE :TREE
LOCAL "DATUM
IF EMPTYP :TREE [OUTPUT [0 NO CITY]]
MAKE "DATUM DATUM :TREE
IF :CODE = AREACODE :DATUM [OUTPUT :DATUM]
IF :CODE < AREACODE :DATUM [OUTPUT TREECITY1 :CODE LOWBRANCH :TREE]
OUTPUT TREECITY1 :CODE HIGHBRANCH :TREE
END

TO WORLDTREE
MAKE "WORLD TREE "WORLD ~
                 (LIST (TREE "FRANCE LEAVES [PARIS DIJON AVIGNON]) ~
                       (TREE "CHINA LEAVES [BEIJING NANKING SHANGHAI CANTON]) ~
                       (TREE [UNITED STATES] ~
                             (LIST (TREE [NEW YORK] ~
                                          LEAVES [[NEW YORK] ALBANY ~
                                                  ROCHESTER ARMONK]) ~
                                   (TREE "MASSACHUSETTS ~
                                         LEAVES [BOSTON CAMBRIDGE ~
                                                 SUDBURY MAYNARD]) ~
                                   (TREE "CALIFORNIA ~
                                         LEAVES [[SAN FRANCISCO] BERKELEY ~
                                                 [PALO ALTO] PASADENA]) ~
                                   (TREE "WASHINGTON ~
                                         LEAVES [SEATTLE OLYMPIA]))) ~
                       (TREE "CANADA ~
                             (LIST (TREE "ONTARIO ~
                                         LEAVES [TORONTO OTTAWA WINDSOR]) ~
                                   (TREE "QUEBEC ~
                                         LEAVES [MONTREAL QUEBEC LACHINE]) ~
                                   (TREE "MANITOBA LEAVES [WINNIPEG]))))
END


MAKE "CODELIST [[202 WASHINGTON] [206 SEATTLE] [212 NEW YORK] [213 LOS ANGELES] ~
                [215 PHILADELPHIA] [303 DENVER] [305 MIAMI] [313 DETROIT] ~
                [314 ST. LOUIS] [401 PROVIDENCE] [404 ATLANTA] [408 SUNNYVALE] ~
                [414 MILWAUKEE] [415 SAN FRANCISCO] [504 NEW ORLEANS] ~
                [608 MADISON] [612 ST. PAUL] [613 KINGSTON] [614 COLUMBUS] ~
                [615 NASHVILLE] [617 BOSTON] [702 LAS VEGAS] [704 CHARLOTTE] ~
                [712 SIOUX CITY] [714 ANAHEIM] [716 ROCHESTER] [717 SCRANTON] ~
                [801 SALT LAKE CITY] [804 NEWPORT NEWS] [805 VENTURA] ~
                [808 HONOLULU]]